home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / kcl.lha / c / typespec.c < prev    next >
C/C++ Source or Header  |  1987-06-04  |  13KB  |  596 lines
  1. /*
  2. (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  3. Copying of this file is authorized to users who have executed the true and
  4. proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  5. */
  6.  
  7. /*
  8.     typespec.c
  9.  
  10.     type specifier routines
  11. */
  12.  
  13. #include "include.h"
  14.  
  15. object
  16. St,        Snil,        Scommon,
  17. Snull,        Scons,        Slist,        Ssymbol,
  18. Sarray,        Svector,    Sbit_vector,    Sstring,
  19. Ssequence,
  20. Ssimple_array,    Ssimple_vector,    Ssimple_bit_vector,
  21.                         Ssimple_string,
  22. Sfunction,    Scompiled_function,
  23.                 Spathname,    Scharacter,
  24. Snumber,    Srational,    Sfloat,        Sstring_char,
  25. Sinteger,    Sratio,        Sshort_float,    Sstandard_char,
  26. Sfixnum,    Scomplex,    Ssingle_float,    Spackage,
  27. Sbignum,    Srandom_state,    Sdouble_float,    Sstream,
  28. Sbit,        Sreadtable,    Slong_float,    Shash_table;
  29.  
  30. object Skeyword;
  31.  
  32. object Sstructure;
  33.  
  34. object Ssatisfies;
  35.  
  36. object Smember;
  37. object Snot;
  38. object Sor;
  39. object Sand;
  40.  
  41. object Svalues;
  42.  
  43. object Smod;
  44. object Ssigned_byte;
  45. object Sunsigned_byte;
  46.  
  47. object SA;        /*  symbol *  */
  48.  
  49. object TSor_symbol_string;
  50. object TSor_string_symbol;
  51. object TSor_symbol_string_package;
  52.  
  53. object TSnon_negative_integer;
  54. object TSor_integer_float;
  55. object TSor_rational_float;
  56.  
  57. #ifdef UNIX
  58. object TSor_pathname_string_symbol;
  59. #endif
  60. object TSor_pathname_string_symbol_stream;
  61.  
  62. check_type_integer(p)
  63. object *p;
  64. {
  65.     enum type t;
  66.  
  67.     while ((t = type_of(*p)) != t_fixnum && t != t_bignum)
  68.         *p = wrong_type_argument(Sinteger, *p);
  69. }
  70.  
  71. check_type_non_negative_integer(p)
  72. object *p;
  73. {
  74.     enum type t;
  75.  
  76.     for (;;) {
  77.         t = type_of(*p);
  78.         if (t == t_fixnum) {
  79.             if (fix((*p)) >= 0)
  80.                 break;
  81.         } else if (t == t_bignum) {
  82.             if (big_sign((struct bignum *)(*p)) >= 0)
  83.                 break;
  84.         }
  85.         *p = wrong_type_argument(TSnon_negative_integer, *p);
  86.     }
  87. }
  88.  
  89. check_type_rational(p)
  90. object *p;
  91. {
  92.     enum type t;
  93.  
  94.     while ((t = type_of(*p)) != t_fixnum &&
  95.            t != t_bignum && t != t_ratio)
  96.         *p = wrong_type_argument(Srational, *p);
  97. }
  98.  
  99. check_type_float(p)
  100. object *p;
  101. {
  102.     enum type t;
  103.  
  104.     while ((t = type_of(*p)) != t_shortfloat && t != t_longfloat)
  105.         *p = wrong_type_argument(Sfloat, *p);
  106. }
  107.  
  108. check_type_or_integer_float(p)
  109. object *p;
  110. {
  111.     enum type t;
  112.  
  113.     while ((t = type_of(*p)) != t_fixnum && t != t_bignum &&
  114.            t != t_shortfloat && t != t_longfloat)
  115.         *p = wrong_type_argument(TSor_integer_float, *p);
  116. }
  117.  
  118. check_type_or_rational_float(p)
  119. object *p;
  120. {
  121.     enum type t;
  122.  
  123.     while ((t = type_of(*p)) != t_fixnum && t != t_bignum &&
  124.            t != t_ratio && t != t_shortfloat && t != t_longfloat)
  125.         *p = wrong_type_argument(TSor_rational_float, *p);
  126. }
  127.  
  128. check_type_number(p)
  129. object *p;
  130. {
  131.     enum type t;
  132.  
  133.     while ((t = type_of(*p)) != t_fixnum && t != t_bignum &&
  134.            t != t_ratio && t != t_shortfloat && t != t_longfloat &&
  135.            t != t_complex)
  136.         *p = wrong_type_argument(Snumber, *p);
  137. }
  138.  
  139. check_type_bit(p)
  140. object *p;
  141. {
  142.     while (type_of(*p) != t_fixnum ||
  143.            fix((*p)) != 0 && fix((*p)) != 1)
  144.         *p = wrong_type_argument(Sbit, *p);
  145. }
  146.  
  147. check_type_character(p)
  148. object *p;
  149. {
  150.     while (type_of(*p) != t_character)
  151.         *p = wrong_type_argument(Scharacter, *p);
  152. }
  153.  
  154. check_type_string_char(p)
  155. object *p;
  156. {
  157.     while (type_of(*p) != t_character ||
  158.            char_font((*p)) != 0 ||
  159.            char_bits((*p)) != 0)
  160.         *p = wrong_type_argument(Scharacter, *p);
  161. }
  162.  
  163. check_type_symbol(p)
  164. object *p;
  165. {
  166.     while (type_of(*p) != t_symbol)
  167.         *p = wrong_type_argument(Ssymbol, *p);
  168. }
  169.  
  170. check_type_or_symbol_string(p)
  171. object *p;
  172. {
  173.     while (type_of(*p) != t_symbol && type_of(*p) != t_string)
  174.         *p = wrong_type_argument(TSor_symbol_string, *p);
  175. }
  176.  
  177. check_type_or_string_symbol(p)
  178. object *p;
  179. {
  180.     while (type_of(*p) != t_symbol && type_of(*p) != t_string)
  181.         *p = wrong_type_argument(TSor_string_symbol, *p);
  182. }
  183.  
  184. check_type_or_symbol_string_package(p)
  185. object *p;
  186. {
  187.     while (type_of(*p) != t_symbol &&
  188.            type_of(*p) != t_string &&
  189.            type_of(*p) != t_package)
  190.         *p = wrong_type_argument(TSor_symbol_string_package,
  191.                         *p);
  192. }
  193.  
  194. check_type_package(p)
  195. object *p;
  196. {
  197.     while (type_of(*p) != t_package)
  198.         *p = wrong_type_argument(Spackage, *p);
  199. }
  200.  
  201. check_type_string(p)
  202. object *p;
  203. {
  204.     while (type_of(*p) != t_string)
  205.         *p = wrong_type_argument(Sstring, *p);
  206. }
  207.  
  208. check_type_bit_vector(p)
  209. object *p;
  210. {
  211.     while (type_of(*p) != t_bitvector)
  212.         *p = wrong_type_argument(Sbit_vector, *p);
  213. }
  214.  
  215. check_type_cons(p)
  216. object *p;
  217. {
  218.     while (type_of(*p) != t_cons)
  219.         *p = wrong_type_argument(Scons, *p);
  220. }
  221.  
  222. check_type_stream(p)
  223. object *p;
  224. {
  225.     while (type_of(*p) != t_stream)
  226.         *p = wrong_type_argument(Sstream, *p);
  227. }
  228.  
  229. check_type_readtable(p)
  230. object *p;
  231. {
  232.     while (type_of(*p) != t_readtable)
  233.         *p = wrong_type_argument(Sreadtable, *p);
  234. }
  235.  
  236. #ifdef UNIX
  237. check_type_or_Pathname_string_symbol(p)
  238. object *p;
  239. {
  240.     enum type t;
  241.  
  242.     while ((t = type_of(*p)) != t_pathname &&
  243.            t != t_string && t != t_symbol)
  244.         *p = wrong_type_argument(
  245.             TSor_pathname_string_symbol, *p);
  246. }
  247. #endif
  248.  
  249. check_type_or_pathname_string_symbol_stream(p)
  250. object *p;
  251. {
  252.     enum type t;
  253.  
  254.     while ((t = type_of(*p)) != t_pathname &&
  255.            t != t_string && t != t_symbol && t != t_stream)
  256.         *p = wrong_type_argument(
  257.             TSor_pathname_string_symbol_stream, *p);
  258. }
  259.  
  260. check_type_random_state(p)
  261. object *p;
  262. {
  263.     while (type_of(*p) != t_random)
  264.         *p = wrong_type_argument(Srandom_state, *p);
  265. }
  266.  
  267. check_type_hash_table(p)
  268. object *p;
  269. {
  270.     while (type_of(*p) != t_hashtable)
  271.         *p = wrong_type_argument(Shash_table, *p);
  272. }
  273.  
  274. check_type_array(p)
  275. object *p;
  276. {
  277. BEGIN:
  278.     switch (type_of(*p)) {
  279.     case t_array:
  280.     case t_vector:
  281.     case t_string:
  282.     case t_bitvector:
  283.         return;
  284.  
  285.     default:
  286.         *p = wrong_type_argument(Sarray, *p);
  287.         goto BEGIN;
  288.     }
  289. }
  290.  
  291. check_type_vector(p)
  292. object *p;
  293. {
  294. BEGIN:
  295.     switch (type_of(*p)) {
  296.     case t_vector:
  297.     case t_string:
  298.     case t_bitvector:
  299.         return;
  300.  
  301.     default:
  302.         *p = wrong_type_argument(Svector, *p);
  303.         goto BEGIN;
  304.     }
  305. }
  306.  
  307. Ltype_of()
  308. {
  309.     int i;
  310.  
  311.     check_arg(1);
  312.  
  313.     switch (type_of(vs_base[0])) {
  314.     case t_fixnum:
  315.         vs_base[0] = Sfixnum;
  316.         break;
  317.  
  318.     case t_bignum:
  319.         vs_base[0] = Sbignum;
  320.         break;
  321.  
  322.     case t_ratio:
  323.         vs_base[0] = Sratio;
  324.         break;
  325.  
  326.     case t_shortfloat:
  327.         vs_base[0] = Sshort_float;
  328.         break;
  329.  
  330.     case t_longfloat:
  331.         vs_base[0] = Slong_float;
  332.         break;
  333.  
  334.     case t_complex:
  335.         vs_base[0] = Scomplex;
  336.         break;
  337.  
  338.     case t_character:
  339.         if (char_font(vs_base[0]) != 0
  340.          || char_bits(vs_base[0]) != 0)
  341.             vs_base[0] = Scharacter;
  342.         else {
  343.             i = char_code(vs_base[0]);
  344.             if (' ' <= i && i < '\177' || i == '\n')
  345.                 vs_base[0] = Sstandard_char;
  346.             else
  347.                 vs_base[0] = Sstring_char;
  348.         }
  349.         break;
  350.  
  351.     case t_symbol:
  352.         if (vs_base[0]->s.s_hpack == keyword_package)
  353.             vs_base[0] = Skeyword;
  354.         else
  355.             vs_base[0] = Ssymbol;
  356.         break;
  357.  
  358.     case t_package:
  359.         vs_base[0] = Spackage;
  360.         break;
  361.  
  362.     case t_cons:
  363.         vs_base[0] = Scons;
  364.         break;
  365.  
  366.     case t_hashtable:
  367.         vs_base[0] = Shash_table;
  368.         break;
  369.  
  370.     case t_array:
  371.         if (vs_base[0]->a.a_adjustable ||
  372.             vs_base[0]->a.a_displaced->c.c_car == Cnil)
  373.             vs_base[0] = Sarray;
  374.         else
  375.             vs_base[0] = Ssimple_array;
  376.         break;
  377.  
  378.     case t_vector:
  379.         if (vs_base[0]->v.v_adjustable ||
  380.             vs_base[0]->v.v_hasfillp ||
  381.             vs_base[0]->v.v_displaced->c.c_car == Cnil ||
  382.             (enum aelttype)vs_base[0]->v.v_elttype != aet_object)
  383.             vs_base[0] = Svector;
  384.         else
  385.             vs_base[0] = Ssimple_vector;
  386.         break;
  387.  
  388.     case t_string:
  389.         if (vs_base[0]->st.st_adjustable ||
  390.             vs_base[0]->st.st_hasfillp ||
  391.             vs_base[0]->st.st_displaced->c.c_car == Cnil)
  392.             vs_base[0] = Sstring;
  393.         else
  394.             vs_base[0] = Ssimple_string;
  395.         break;
  396.  
  397.     case t_bitvector:
  398.         if (vs_base[0]->bv.bv_adjustable ||
  399.             vs_base[0]->bv.bv_hasfillp ||
  400.             vs_base[0]->bv.bv_displaced->c.c_car == Cnil)
  401.             vs_base[0] = Sbit_vector;
  402.         else
  403.             vs_base[0] = Ssimple_bit_vector;
  404.         break;
  405.  
  406.     case t_structure:
  407.         vs_base[0] = vs_base[0]->str.str_name;
  408.         break;
  409.  
  410.     case t_stream:
  411.         vs_base[0] = Sstream;
  412.         break;
  413.  
  414.     case t_readtable:
  415.         vs_base[0] = Sreadtable;
  416.         break;
  417.  
  418.     case t_pathname:
  419.         vs_base[0] = Spathname;
  420.         break;
  421.  
  422.     case t_random:
  423.         vs_base[0] = Srandom_state;
  424.         break;
  425.  
  426.     case t_cfun:
  427.     case t_cclosure:
  428.         vs_base[0] = Scompiled_function;
  429.         break;
  430.  
  431.     default:
  432.         error("not a lisp data object");
  433.     }
  434. }
  435.  
  436. init_typespec()
  437. {
  438.     St = make_ordinary("T");
  439.     enter_mark_origin(&St);
  440.     Snil = make_ordinary("NIL");
  441.     enter_mark_origin(&Snil);
  442.     Scommon = make_ordinary("COMMON");
  443.     enter_mark_origin(&Scommon);
  444.     Snull = make_ordinary("NULL");
  445.     enter_mark_origin(&Snull);
  446.     Scons = make_ordinary("CONS");
  447.     enter_mark_origin(&Scons);
  448.     Slist = make_ordinary("LIST");
  449.     enter_mark_origin(&Slist);
  450.     Ssymbol = make_ordinary("SYMBOL");
  451.     enter_mark_origin(&Ssymbol);
  452.     Sarray = make_ordinary("ARRAY");
  453.     enter_mark_origin(&Sarray);
  454.     Svector = make_ordinary("VECTOR");
  455.     enter_mark_origin(&Svector);
  456.     Sbit_vector = make_ordinary("BIT-VECTOR");
  457.     enter_mark_origin(&Sbit_vector);
  458.     Sstring = make_ordinary("STRING");
  459.     enter_mark_origin(&Sstring);
  460.     Ssequence = make_ordinary("SEQUENCE");
  461.     enter_mark_origin(&Ssequence);
  462.     Ssimple_array = make_ordinary("SIMPLE-ARRAY");
  463.     enter_mark_origin(&Ssimple_array);
  464.     Ssimple_vector = make_ordinary("SIMPLE-VECTOR");
  465.     enter_mark_origin(&Ssimple_vector);
  466.     Ssimple_bit_vector = make_ordinary("SIMPLE-BIT-VECTOR");
  467.     enter_mark_origin(&Ssimple_bit_vector);
  468.     Ssimple_string = make_ordinary("SIMPLE-STRING");
  469.     enter_mark_origin(&Ssimple_string);
  470.     Sfunction = make_ordinary("FUNCTION");
  471.     enter_mark_origin(&Sfunction);
  472.     Scompiled_function = make_ordinary("COMPILED-FUNCTION");
  473.     enter_mark_origin(&Scompiled_function);
  474.     Spathname = make_ordinary("PATHNAME");
  475.     enter_mark_origin(&Spathname);
  476.     Scharacter = make_ordinary("CHARACTER");
  477.     enter_mark_origin(&Scharacter);
  478.     Snumber = make_ordinary("NUMBER");
  479.     enter_mark_origin(&Snumber);
  480.     Srational = make_ordinary("RATIONAL");
  481.     enter_mark_origin(&Srational);
  482.     Sfloat = make_ordinary("FLOAT");
  483.     enter_mark_origin(&Sfloat);
  484.     Sstring_char = make_ordinary("STRING-CHAR");
  485.     enter_mark_origin(&Sstring_char);
  486.     Sinteger = make_ordinary("INTEGER");
  487.     enter_mark_origin(&Sinteger);
  488.     Sratio = make_ordinary("RATIO");
  489.     enter_mark_origin(&Sratio);
  490.     Sshort_float = make_ordinary("SHORT-FLOAT");
  491.     enter_mark_origin(&Sshort_float);
  492.     Sstandard_char = make_ordinary("STANDARD-CHAR");
  493.     enter_mark_origin(&Sstandard_char);
  494.     Sfixnum = make_ordinary("FIXNUM");
  495.     enter_mark_origin(&Sfixnum);
  496.     Scomplex = make_ordinary("COMPLEX");
  497.     enter_mark_origin(&Scomplex);
  498.     Ssingle_float = make_ordinary("SINGLE-FLOAT");
  499.     enter_mark_origin(&Ssingle_float);
  500.     Spackage = make_ordinary("PACKAGE");
  501.     enter_mark_origin(&Spackage);
  502.     Sbignum = make_ordinary("BIGNUM");
  503.     enter_mark_origin(&Sbignum);
  504.     Srandom_state = make_ordinary("RANDOM-STATE");
  505.     enter_mark_origin(&Srandom_state);
  506.     Sdouble_float = make_ordinary("DOUBLE-FLOAT");
  507.     enter_mark_origin(&Sdouble_float);
  508.     Sstream = make_ordinary("STREAM");
  509.     enter_mark_origin(&Sstream);
  510.     Sbit = make_ordinary("BIT");
  511.     enter_mark_origin(&Sbit);
  512.     Sreadtable = make_ordinary("READTABLE");
  513.     enter_mark_origin(&Sreadtable);
  514.     Slong_float = make_ordinary("LONG-FLOAT");
  515.     enter_mark_origin(&Slong_float);
  516.     Shash_table = make_ordinary("HASH-TABLE");
  517.     enter_mark_origin(&Shash_table);
  518.     
  519.     Skeyword = make_ordinary("KEYWORD");
  520.     enter_mark_origin(&Skeyword);
  521.  
  522.     Sstructure = make_ordinary("STRUCTURE");
  523.     enter_mark_origin(&Sstructure);
  524.  
  525.     Ssatisfies = make_ordinary("SATISFIES");
  526.     enter_mark_origin(&Ssatisfies);
  527.     
  528.     Smember = make_ordinary("MEMBER");
  529.     enter_mark_origin(&Smember);
  530.     Snot = make_ordinary("NOT");
  531.     enter_mark_origin(&Snot);
  532.     Sor = make_ordinary("OR");
  533.     enter_mark_origin(&Sor);
  534.     Sand = make_ordinary("AND");
  535.     enter_mark_origin(&Sand);
  536.     
  537.     Svalues = make_ordinary("VALUES");
  538.     enter_mark_origin(&Svalues);
  539.     
  540.     Smod = make_ordinary("MOD");
  541.     enter_mark_origin(&Smod);
  542.     Ssigned_byte = make_ordinary("SIGNED-BYTE");
  543.     enter_mark_origin(&Ssigned_byte);
  544.     Sunsigned_byte = make_ordinary("UNSIGNED-BYTE");
  545.     enter_mark_origin(&Sunsigned_byte);
  546.  
  547.     SA = make_ordinary("*");
  548.     enter_mark_origin(&SA);
  549. }
  550.  
  551. init_typespec_function()
  552. {
  553.     TSor_symbol_string
  554.     = make_cons(Sor, make_cons(Ssymbol, make_cons(Sstring, Cnil)));
  555.     enter_mark_origin(&TSor_symbol_string);
  556.     TSor_string_symbol
  557.     = make_cons(Sor, make_cons(Sstring, make_cons(Ssymbol, Cnil)));
  558.     enter_mark_origin(&TSor_string_symbol);
  559.     TSor_symbol_string_package
  560.     = make_cons(Sor,
  561.             make_cons(Ssymbol,
  562.                   make_cons(Sstring,
  563.                     make_cons(Spackage, Cnil))));
  564.     enter_mark_origin(&TSor_symbol_string_package);
  565.  
  566.     TSnon_negative_integer
  567.     = make_cons(Sinteger,
  568.             make_cons(make_fixnum(0), make_cons(SA, Cnil)));
  569.     enter_mark_origin(&TSnon_negative_integer);
  570.     TSor_integer_float
  571.     = make_cons(Sor, make_cons(Sinteger, make_cons(Sfloat, Cnil)));
  572.     enter_mark_origin(&TSor_integer_float);
  573.     TSor_rational_float
  574.     = make_cons(Sor, make_cons(Srational, make_cons(Sfloat, Cnil)));
  575.     enter_mark_origin(&TSor_rational_float);
  576. #ifdef UNIX
  577.     TSor_pathname_string_symbol
  578.     = make_cons(Sor,
  579.             make_cons(Spathname,
  580.                   make_cons(Sstring,
  581.                     make_cons(Ssymbol,
  582.                           Cnil))));
  583.     enter_mark_origin(&TSor_pathname_string_symbol);
  584. #endif
  585.     TSor_pathname_string_symbol_stream
  586.     = make_cons(Sor,
  587.             make_cons(Spathname,
  588.                   make_cons(Sstring,
  589.                     make_cons(Ssymbol,
  590.                           make_cons(Sstream,
  591.                                 Cnil)))));
  592.     enter_mark_origin(&TSor_pathname_string_symbol_stream);
  593.  
  594.     make_function("TYPE-OF", Ltype_of);
  595. }                
  596.